VERSION 5.00
Object = "{8E27C92E-1264-101C-8A2F-040224009C02}#7.0#0"; "MSCAL.OCX"
Begin VB.Form frmPurge 
   BackColor       =   &H00FFFFFF&
   Caption         =   "Purge Database"
   ClientHeight    =   3480
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5415
   Icon            =   "frmPurge.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   3480
   ScaleWidth      =   5415
   StartUpPosition =   1  'CenterOwner
   Begin VB.CommandButton cmdCancel 
      Appearance      =   0  'Flat
      BackColor       =   &H00E0E0E0&
      Caption         =   "&Cancel"
      Height          =   315
      Left            =   3000
      MaskColor       =   &H0080C0FF&
      Style           =   1  'Graphical
      TabIndex        =   5
      Top             =   3000
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdContinue 
      Appearance      =   0  'Flat
      BackColor       =   &H00E0E0E0&
      Caption         =   "C&ontinue"
      Height          =   315
      Left            =   1200
      MaskColor       =   &H00E0E0E0&
      Style           =   1  'Graphical
      TabIndex        =   4
      Top             =   3000
      Width           =   1215
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H00FFFFFF&
      Caption         =   "Select Date"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000080FF&
      Height          =   2655
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   4935
      Begin MSACAL.Calendar Calendar1 
         Height          =   2295
         Left            =   960
         TabIndex        =   1
         Top             =   240
         Visible         =   0   'False
         Width           =   3015
         _Version        =   524288
         _ExtentX        =   5318
         _ExtentY        =   4048
         _StockProps     =   1
         BackColor       =   16777215
         Year            =   2004
         Month           =   2
         Day             =   9
         DayLength       =   1
         MonthLength     =   2
         DayFontColor    =   0
         FirstDay        =   1
         GridCellEffect  =   1
         GridFontColor   =   10485760
         GridLinesColor  =   -2147483632
         ShowDateSelectors=   -1  'True
         ShowDays        =   -1  'True
         ShowHorizontalGrid=   -1  'True
         ShowTitle       =   0   'False
         ShowVerticalGrid=   -1  'True
         TitleFontColor  =   10485760
         ValueIsNull     =   -1  'True
         BeginProperty DayFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Arial"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         BeginProperty GridFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Arial"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         BeginProperty TitleFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Arial"
            Size            =   12
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
      Begin VB.TextBox txtPurgeDate 
         Height          =   315
         Left            =   2280
         TabIndex        =   2
         Top             =   1080
         Width           =   1095
      End
      Begin VB.Label lblStatus 
         Alignment       =   2  'Center
         BackColor       =   &H00FFFFFF&
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   12
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H000000C0&
         Height          =   495
         Left            =   1080
         TabIndex        =   6
         Top             =   1680
         Width           =   2895
      End
      Begin VB.Label Label15 
         Alignment       =   1  'Right Justify
         BackColor       =   &H00FFFFFF&
         Caption         =   "Prior to Date:"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   960
         TabIndex        =   3
         Top             =   1140
         Width           =   1215
      End
      Begin VB.Image Image1 
         Height          =   345
         Left            =   3480
         Picture         =   "frmPurge.frx":1272
         Stretch         =   -1  'True
         Top             =   1080
         Width           =   345
      End
   End
End
Attribute VB_Name = "frmPurge"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'---------------------------------------------------------------------------------------
' Procedure : Calendar1_DblClick()
' DateTime  : 4/8/2004
' Purpose   : Puts date selected on calendar in Purge Date field.
'---------------------------------------------------------------------------------------
'
Private Sub Calendar1_DblClick()
    txtPurgeDate = Calendar1.Value
    Calendar1.Visible = False
End Sub
'---------------------------------------------------------------------------------------
' Procedure : cmdCancel_Click()
' DateTime  : 4/8/2004
' Purpose   : Hides Purge Form
'---------------------------------------------------------------------------------------
'
Private Sub cmdCancel_Click()
    lblStatus = ""
    lblStatus.ForeColor = &HC0&
    cmdCancel.Caption = "&Cancel"
    Me.Hide
    If frmShip.Visible Then frmShip.SetFocus
    '20071102-01 Added to clear message if PurgeCheck was user to notify user to purge.
    Call SetMessage("")
End Sub
'---------------------------------------------------------------------------------------
' Procedure : cmdContinue_Click()
' DateTime  : 4/8/2004
' Modified  : 11/23/2004 Added coe for deleting batch test files
' Purpose   : Verifies user wishes to purge, if so call routines to purge and compact.
'---------------------------------------------------------------------------------------
'
Private Sub cmdContinue_Click()
    Dim Reply
    Dim strDir As String
    
    '11/23 Get the directory where the batch text files are saved
    With frmSetup
        strDir = IIf(.txtFilesPath = "", App.Path, .txtFilesPath)
    End With
    
    Reply = MsgBox("All package information will be deleted prior to " & txtPurgeDate & vbCrLf _
            & "Do you want to continue?", vbYesNo, "Purge Database")
    
    If Reply = vbYes Then
        lblStatus = "Purging..."
        Call PurgeDatabase
        Call CompactDatabase
        lblStatus = "Purge Complete"
        lblStatus.ForeColor = &H8000&
        '11/23 Check to ensure user wants to delete text files
        Reply = MsgBox("All Batch processing text files will be deleted from:" & vbCrLf _
                & strDir & vbCrLf & "Do you want to continue?", vbYesNo, "Delete Batch Text Files")
        If Reply = vbYes Then
            Call DeleteFiles(strDir & "\")
            lblStatus = "Files Deleted"
        End If
        cmdCancel.Caption = "OK"
    Else
        Me.Hide
    End If
End Sub

Private Sub Form_Activate()
    txtPurgeDate.SetFocus
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Form_KeyDown()
' DateTime  : 2/17/2005
' Purpose   : Enter key pressed sends a TAB to move to next field
'---------------------------------------------------------------------------------------
'
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If Not TypeOf Me.ActiveControl Is CommandButton Then
        If Shift = 0 And KeyCode = 13 Then
            SendKeys "{TAB}"
        End If
    End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : Form_Load()
' DateTime  : 4/8/2004
' Purpose   : Set Purge Date and Calendar date to today.
'---------------------------------------------------------------------------------------
'
Private Sub Form_Load()
    txtPurgeDate = Date - 30
    Calendar1.Value = Date - 30
End Sub
'---------------------------------------------------------------------------------------
' Procedure : Image1_Click()
' DateTime  : 4/8/2004
' Purpose   : Show the Calendar
'---------------------------------------------------------------------------------------
'
Private Sub Image1_Click()
    Calendar1.Visible = True
End Sub
'---------------------------------------------------------------------------------------
' Procedure : PurgeDatabase()
' DateTime  : 4/5/2005
' Purpose   : Deletes all records prio to purge date in IntlCommodities, MPS, &
'             Shipments tables.
'             Update 4/5/2005 - removed IntlCommodities and MPS tables since information
'             is now deleted at time of shipment. Added SmartPost and IPD tables.
'             Update 9/13/2005 - added deletion of Returns records.
'             Update 2/1/2006 - added deletion of Tags and LTL records.
'---------------------------------------------------------------------------------------
'
Private Sub PurgeDatabase()
    On Error GoTo EH
    
    Dim strQuery
    
    strQuery = "DELETE FROM Shipments WHERE g_str24 < " & SingleQuotes(Format(txtPurgeDate, "YYYYMMDD"))
    g_connFSMSClient.Execute strQuery
    strQuery = "DELETE FROM SmartPost WHERE g_str24 < " & SingleQuotes(Format(txtPurgeDate, "YYYYMMDD"))
    g_connFSMSClient.Execute strQuery
    strQuery = "DELETE FROM IPD WHERE g_str24 < " & SingleQuotes(Format(txtPurgeDate, "YYYYMMDD"))
    g_connFSMSClient.Execute strQuery
    strQuery = "DELETE FROM Returns WHERE g_str24 < " & SingleQuotes(Format(txtPurgeDate, "YYYYMMDD"))
    g_connFSMSClient.Execute strQuery
    strQuery = "DELETE FROM Tags WHERE f1365 < " & SingleQuotes(Format(txtPurgeDate, "YYYYMMDD"))
    g_connFSMSClient.Execute strQuery
    strQuery = "DELETE FROM LTLShipments WHERE f24 < " & SingleQuotes(Format(txtPurgeDate, "YYYYMMDD"))
    g_connFSMSClient.Execute strQuery

    Exit Sub

EH:
    MsgBox Err.Description, vbCritical, "frmPurge.PurgeDatabase"

End Sub
'---------------------------------------------------------------------------------------
' Procedure : CompactDatabase()
' DateTime  : 8/10/2005
' Purpose   : Compacts the database
'---------------------------------------------------------------------------------------
'
Private Sub CompactDatabase()

    Dim strSource As String
    Dim strDest As String
    Dim fs As New FileSystemObject
    Dim objJet As New JRO.JetEngine
    
    Const JetConn = "Provider=Microsoft.Jet.OLEDB.4.0; Data source="
    
    On Error GoTo Release
    
    'Close FSMS Client connection
    g_connFSMSClient.Close
        
    'Set source and destination database names
    strSource = App.Path & "\FSMSClient.mdb"
    strDest = App.Path & "\FSMSClientNew.mdb"
    
    'Compact the DB
    objJet.CompactDatabase JetConn & strSource, JetConn & strDest
    
    'Delete old DB
    fs.DeleteFile strSource, True
    'Copy destination to FSMSClient.mdb
    fs.CopyFile strDest, App.Path & "\FSMSClient.mdb"
    'Delete destination DB
    fs.DeleteFile strDest
    
Release:
    
    Set fs = Nothing
    Set objJet = Nothing
    
    'Open database connection
    Call frmDGDisclaimer.FSMSClientMDBConnect

End Sub
'---------------------------------------------------------------------------------------
' Procedure : DeleteFiles
' DateTime  : 11/23/2004
' Purpose   : Delete Text Files from FilesPath or App.Path
'---------------------------------------------------------------------------------------
'
Private Sub DeleteFiles(ByVal strPath As String)
    Dim FSO As New Scripting.FileSystemObject
    
    On Error GoTo EH
    
    FSO.DeleteFile strPath & "*.txt", True
    
Release:
    Set FSO = Nothing
    Exit Sub

EH:
    MsgBox Err.Description, vbCritical, "frmPurge.DeleteFiles"
    Resume Release

End Sub

Private Sub txtPurgeDate_GotFocus()
    Call SelectAllText(txtPurgeDate)
End Sub
